Deutsche Edition 1/Deutsche Edition 1.iso/amok/amok_lha/amok24.lha/Clusters/Clusters.mod

Text File | 1993-08-15 | 7KB | 249 lines

(**********************************************************************

    :Program.    Clusters.mod
    :Contents.   Block oriented memory management
    :Author.     Nicolas Benezan [bne]
    :Address.    Postwiesenstr. 2, D7000 Stuttgart 60
    :Phone.      [phone]
    :Copyright.  Public Domain
    :Language.   Modula-2
    :Translator. M2Amiga A+L V3.2d
    :Imports.    BigSets, TaskMemory [bne]
    :History.    V1.0 [bne] 02.Jul.1989
    :History.    V1.1 [bne] 09.Jul.1989 (TYPEs optimized, bugs fixed)

**********************************************************************)

IMPLEMENTATION MODULE Clusters;

FROM BigSets    IMPORT BigSet, CreateBigSet, DiscardBigSet, Exclude,
                       FindNextClear, Include;
FROM SYSTEM     IMPORT ADDRESS, ADR;
IMPORT TaskMemory;

TYPE
  ClusterPtrPtr=POINTER TO ClusterPtr;

CONST
  PtrSize=SIZE(ClusterPtrPtr);

VAR
  AllocProc: AllocationProc;
  DeallocProc: DeallocationProc;
  Dummy: BOOLEAN;

PROCEDURE Reset;
  BEGIN
    AllocProc:=TaskMemory.Allocate;
    DeallocProc:=TaskMemory.Deallocate;
    NumHeaps:=0;
  END Reset;

PROCEDURE InitMemManager(Allocation: AllocationProc;
                         Deallocation: DeallocationProc;
                         ClusterSize: LONGINT;
                         BlockSizes: ARRAY OF LONGINT): BOOLEAN;
  VAR
    HeapNum:CARDINAL;
    CurrentHeap:HeapPtr;
  BEGIN
    AllocProc:=Allocation;
    DeallocProc:=Deallocation;
    NumHeaps:=HIGH(BlockSizes)+1;
    AllocProc(HeapArray, NumHeaps*SIZE(Heap));
    IF HeapArray#NIL THEN
      CurrentHeap:=HeapArray;
      FOR HeapNum:=0 TO HIGH(BlockSizes) DO
        WITH CurrentHeap^ DO
          clusterList:=NIL;
          firstFreeCluster:=NIL;
          clusterSize:=ClusterSize;
          blockSize:=BlockSizes[HeapNum]+PtrSize;
          blocksPerCluster:=(clusterSize-SIZE(Cluster)) DIV blockSize;
        END;
        INC(CurrentHeap, SIZE(Heap));
      END;
      RETURN TRUE;
    ELSE
      Reset;
      RETURN FALSE;
    END;
  END InitMemManager;

PROCEDURE Allocate(VAR Pointer: ADDRESS;
                       Size: LONGINT);
  VAR
    CurrentHeap: HeapPtr;
    FirstAddress: ClusterPtrPtr;

  PROCEDURE FindHeap(): BOOLEAN;
    VAR
      HeapNum: CARDINAL;
    BEGIN
      CurrentHeap:=HeapArray;
      FOR HeapNum:=1 TO NumHeaps DO
        IF CurrentHeap^.blockSize=Size THEN
          RETURN TRUE
        END;
        INC(CurrentHeap, SIZE(Heap));
      END;
      RETURN FALSE;
    END FindHeap;

  PROCEDURE AddCluster(): BOOLEAN;
    VAR
      Pred, Node: ClusterPtr;
    BEGIN
      WITH CurrentHeap^ DO
        AllocProc(firstFreeCluster, clusterSize);
        IF firstFreeCluster#NIL THEN
          WITH firstFreeCluster^ DO
            heap:=CurrentHeap;
            firstFreeBlock:=0;
            freeBlocks:=blocksPerCluster;
            IF CreateBigSet(blockAllocMap, blocksPerCluster) THEN
              (* scan list to find the right place *)
              Pred:=ADR(clusterList);
              Node:=clusterList;
              WHILE (Node#NIL) AND
                    (LONGINT(Node)<LONGINT(firstFreeCluster)) DO
                Pred:=Node;
                Node:=Node^.next;
              END;
              (* insert new cluster into Heap.clusterList *)
              next:=Node;
              IF next#NIL THEN
                next^.pred:=firstFreeCluster;
              END;
              Pred^.next:=firstFreeCluster;
              pred:=Pred;
              RETURN TRUE
            END;
          END;
          DeallocProc(firstFreeCluster);
        END;
      END;
      RETURN FALSE;
    END AddCluster;

  BEGIN
    INC(Size, PtrSize);
    IF FindHeap() THEN
      WITH CurrentHeap^ DO
        IF firstFreeCluster=NIL THEN
          IF NOT AddCluster() THEN
            Pointer:=NIL;
            RETURN
          END;
        END;
        WITH firstFreeCluster^ DO
          (* allocate block *)
          Include(blockAllocMap, firstFreeBlock);
          FirstAddress:=ADDRESS(LONGINT(firstFreeCluster)+SIZE(Cluster)+
                                blockSize*LONGINT(firstFreeBlock));
          FirstAddress^:=firstFreeCluster;
          Pointer:=LONGINT(FirstAddress)+PtrSize;
          DEC(freeBlocks);
        END;
        (* search next free block *)
        LOOP
          IF firstFreeCluster^.freeBlocks=0 THEN
            (* no more free blocks in this cluster *)
            firstFreeCluster:=firstFreeCluster^.next;
            IF firstFreeCluster=NIL THEN
              (* no more free blocks in this heap *)
              EXIT
            END;
          ELSE
            WITH firstFreeCluster^ DO
              Dummy:=FindNextClear(blockAllocMap, firstFreeBlock);
            END;
            EXIT
          END;
        END;
      END;
    ELSE
      (* allocate independent block *)
      AllocProc(FirstAddress, Size);
      IF FirstAddress#NIL THEN
        FirstAddress^:=NIL;
        Pointer:=LONGINT(FirstAddress)+PtrSize;
      ELSE
        Pointer:=NIL;
      END;
    END;
  END Allocate;

PROCEDURE Deallocate(VAR Pointer: ADDRESS);
  VAR
    CurrentBlock: CARDINAL;
    CurrentCluster: ClusterPtr;
  BEGIN
    CurrentBlock:=FindBlock(Pointer, CurrentCluster);
    IF CurrentCluster#NIL THEN
      Pointer:=NIL;
      WITH CurrentCluster^ DO
        WITH heap^ DO
          (* deallocate block *)
          Exclude(blockAllocMap, CurrentBlock);
          INC(freeBlocks);
          IF freeBlocks#blocksPerCluster THEN
            (* restore <firstFreeBlock> *)
            IF (CurrentBlock<firstFreeBlock) OR (freeBlocks=1) THEN
              firstFreeBlock:=CurrentBlock;
            END;
            (* restore <firstFreeCluster> *)
            IF (LONGINT(CurrentCluster)<LONGINT(firstFreeCluster)) OR
               (firstFreeCluster=NIL) THEN
              firstFreeCluster:=CurrentCluster;
            END;
          ELSE
            (* remove cluster from Heap.clusterList *)
            pred^.next:=next;
            IF next#NIL THEN
              next^.pred:=pred;
            END;
            (* restore <firstFreeCluster> *)
            IF firstFreeCluster=CurrentCluster THEN
              firstFreeCluster:=next;
              WHILE (firstFreeCluster#NIL) AND
                    (firstFreeCluster^.freeBlocks=0) DO
                firstFreeCluster:=firstFreeCluster^.next;
              END;
            END;
            (* delete cluster *)
            DiscardBigSet(blockAllocMap);
            DeallocProc(CurrentCluster);
          END;
        END;
      END;
    ELSE
      (* deallocate independent block *)
      DEC(Pointer, PtrSize);
      DeallocProc(Pointer);
    END;
  END Deallocate;

PROCEDURE FindBlock(    Block: ADDRESS;
                    VAR ClPtr: ClusterPtr): CARDINAL;
  VAR
    FirstAddress: ClusterPtrPtr;
    BlockSize: LONGINT;
  BEGIN
    DEC(Block, PtrSize);
    FirstAddress:=Block;
    ClPtr:=FirstAddress^;
    IF ClPtr#NIL THEN
      DEC(Block, LONGINT(ClPtr));
      DEC(Block, SIZE(Cluster));
      BlockSize:=ClPtr^.heap^.blockSize;
      RETURN LONGINT(Block) DIV BlockSize;
    END;
    RETURN 0;
  END FindBlock;

BEGIN
  Reset;
END Clusters.